home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 October / macformat-005.iso / Shareware City / Developers / xlispmac / lisp / MATCH.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-28  |  2.7 KB  |  110 lines  |  [TEXT/xlsp]
  1. ;; Pattern matching Chapter 24 Winston&Horn 3rd Edition
  2.  
  3.  
  4. (defun add-binding (pve datum bindings)
  5.     (if (eq '_ (extract-variable pve))
  6.         bindings
  7.         (cons (make-binding (extract-variable pve) datum) bindings)))
  8.  
  9. (defun extract-variable (pve) (second pve))
  10.  
  11. (defun make-binding (variable datum) (list variable datum))
  12.  
  13. (defun find-binding (pve binding)
  14.     (unless (eq '_ (extract-variable pve))
  15.         (assoc (extract-variable pve) binding)))
  16.  
  17.  
  18. (defun extract-key (binding) (first binding))
  19. (defun extract-value (binding) (second binding))
  20.  
  21. (defun match-atoms (p d bindings)
  22.     (if  (eql p d)
  23.          bindings
  24.          'fail))
  25.  
  26. (defun match-variable (p d bindings)
  27.     (let ((binding (find-binding p bindings)))
  28.          (if binding
  29.              (match (extract-value binding) d bindings)
  30.          (add-binding p d bindings))))
  31.  
  32. (defun match-pieces (p d bindings)
  33.     (let ((result (match (first p) (first d) bindings)))
  34.          (if (eq 'fail result)
  35.              'fail
  36.          (match (rest p) (rest d) result))))
  37.  
  38. (defun elements-p (p d)
  39.     (and (atom p) (atom d)))
  40.  
  41. (defun variable-p (p)
  42.     (and (listp p) (eq '? (first p))))
  43.  
  44. (defun recursive-p (p d)
  45.     (and (listp p) (listp d)))
  46.  
  47. (defun match (p d &optional bindings)
  48.     (cond ((elements-p p d)
  49.            (match-atoms p d bindings))
  50.           ((variable-p p)
  51.            (match-variable p d bindings))
  52.           ((recursive-p p d)
  53.            (match-pieces p d bindings))
  54.           (t 'fail)))
  55.  
  56. (defun unify-atoms (p1 p2 bindings)
  57.     (if  (eql p1 p2)
  58.          bindings
  59.          'fail))
  60.  
  61. (defun unify-pieces (p1 p2 bindings)
  62.     (let ((result (unify (first p1) (first p2) bindings)))
  63.          (if (eq 'fail result)
  64.              'fail
  65.          (unify (rest p1) (rest p2) result))))
  66.  
  67. (defun insidep (variable expression bindings)
  68.     (if (equal variable expression)
  69.         nil
  70.         (inside-or-equal-p variable expression bindings)))
  71.  
  72. (defun inside-or-equal-p (variable expression bindings)
  73.    (cond ((equal variable expression) t)
  74.         ((atom expression) nil)
  75.      ((eq '? (first expression))
  76.       (let ((binding (find-binding expression bindings)))
  77.            (when binding
  78.                  (inside-or-equal-p variable (first expression) bindings))))
  79.      (t (or (inside-or-equal-p variable (first expression) bindings)
  80.          (inside-or-equal-p variable (rest expression) bindings)))))
  81.  
  82. (defun unify-variable (p1 p2 bindings)
  83.     (let ((binding (find-binding p1 bindings)))
  84.          (if binding
  85.              (unify (extract-value binding) p2 bindings)
  86.          (if (insidep p1 p2 bindings)
  87.              'fail
  88.              (add-binding p1 p2 bindings)))))
  89.  
  90. (defun unify (p1 p2 &optional bindings)
  91.     (cond ((elements-p p1 p2)
  92.            (unify-atoms p1 p2 bindings))
  93.           ((variable-p p1)
  94.            (unify-variable p1 p2 bindings))
  95.           ((variable-p p2)
  96.            (unify-variable p2 p1 bindings))
  97.           ((recursive-p p1 p2)
  98.            (unify-pieces p1 p2 bindings))
  99.           (t 'fail)))
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.